perm filename JUST.F4[NEW,LCS]2 blob sn#155906 filedate 1975-04-18 generic text, type T, neo UTF8
00100	C  TO JUSTIFY SEVERAL MSS FILES AT ONCE. (UP TO 15.)(8*15=120)
00110	C TO CONVERT(ONE FILE AT A TIME)TO NEW FORMAT, USE 'CONVT' AS 'LAST NAME'.
00200		COMMON/XRN/ RN(20000)/PTR/PWDS(2500) ,RSTFAC(120),STFF(120),
00400		1 V(200),JR(120)/RR4/R4,R5,P1,P2,I,M
00450	C  M=NUM OF STAVES. (BY 8S)
00500		COMMON JY,L,R8,R9,RDIS /RS/JW(120)
00550		
00700		TYPE 1
00800	1	FORMAT(' FILE NAME 1?  '$)
00900		ACCEPT 200,N1
01000	200	FORMAT(A5)
01100		TYPE 300
01200	300	FORMAT(' LAST NAME?  '$)
01300		ACCEPT 200,N2
01310		TYPE 3011
01320	3011	FORMAT(' TYPE OUTPUT NAME 1 -- '$)
01330		ACCEPT 200,NMX
01340		IF(N2.EQ.'CONVT')GO TO 111
01400		TYPE 100
01500	100	FORMAT(' POS.1, POS.2 -  '$)
01600		ACCEPT 111,P1,P2
01650		IF(P2.EQ.0)P2=200
01700	111	FORMAT(2F)
01800		IF(NMX.EQ.' ')NMX='AAAAA'
01900	
01910		JW(1)=1
01920		JR(1)=1
02000		M=1
02100		L=0
02200		JX=1
02300		IX=1
02400		NX=1
02500		NM=N1
02600	40	CALL IFILE(1,NM)
02700		READ (1)J,I,
02800		1 (PWDS(K),K=JX,JX+J),(RN(K),K=IX,I+IX-2),ISCR,(V(K),K=1,ISCR),
02900		1 ISCR,(V(K),K=1,ISCR),(RSTFAC(K),K=NX,NX+7),(STFF(K),K=
03000		1 NX,NX+7),K
03100	
03200		IF(N2.EQ.'CONVT')GO TO 2
03210	C ********* TYPE 999 AS POS1. FOR 'CONVERT', NAME2 WILL BE OUTPUT NM.
03300		RX=NX-1
03500	
03560		IF(RX.EQ.0)GO TO 410
03600		DO 41 K=JX,JX+J
03700		PWDS(K)=PWDS(K)+L
03800		KX=PWDS(K)+2
03820	C  +2 IS FOR STAFF #
03840	41	RN(KX)=RN(KX)+RX
03900	410	IX=I+IX-1
03910		L=IX-1
04000		JX=J+JX
04010		JW(M+1)=JX
04020	C  POINTER TO START OF PWDS FOR EACH FILE
04030		JR(M+1)=IX  
04100		NX=NX+8
04200		IF(IX.LT.19500)GO TO 400
04300		RRT=IX
04400		TYPE 111,RRT
04500	400	IF(NM.EQ.N2)GO TO 5
04600		NM=NM+2
04700		M=M+1
04800		GO TO 40
04900	
05700	2	JJ=1
05800	3001	L=PWDS(JJ)
05900		K=L+1
06000		A=RN(K)
06010		Z=RN(L)
06100		IF(A.LT.5)GO TO 3002
06200		IF(A.LE.10)GO TO 1177
06250		IF(A.NE.20)GO TO 3002
06300	1177	IF(A.NE.6)GO TO 3003
06400		RN(K)=9
06500		GO TO 3002
06600	3003	IF(A.NE.5)GO TO 3004
06700		RN(K)=10
06800		IF(Z.LT.4)GO TO 3010
07000		CALL EXCH(RN(L+5),RN(L+6))
07200		GO TO 3002
07300	3004	IF(A.NE.7)GO TO 3005
07400		RN(K)=17
07500		GO TO 3010
07600	3005	IF(A.EQ.8)RN(K)=5
07700		IF(A.EQ.9)RN(K)=6
07800		IF(A.NE.10)GO TO 3006
07900		RN(K)=8
07910		IF(Z.LT.4)GO TO 3010
07920		CALL EXCH(RN(L+4),RN(L+5))
07930		CALL EXCH(RN(L+6),RN(L+5))
08000	 	GO TO 3002
08100	3006	IF(A.EQ.20)RN(K)=7
08200		IF(A.NE.18)GO TO 3002
08300	3010	FORMAT(' ITEM ',I3,', CODE ',F3.0)
08400		TYPE 3010,JJ,A
08410	3002	A=RN(L+2)
08420		RN(L+2)=RN(L+3)
08430		RN(L+3)=A
08500		A=L+Z+3
08600		JJ=JJ+1
08700		IF(A.EQ.PWDS(JJ))GO TO 3001
10000		MX=1
10100	CC	IF(N2.NE.' ')NM=N2
10200		GO TO 6
10300	
10400	5	I=JX-1
10500	C  TOTAL IN RN ('I' IN MXX.F4)
10600		CALL JJUST
10700	
10800	C  START OF WRITER
10810	6	NM=NMX
10900		JX=1
11000		IX=1
11100		NX=1
11300		L=0
11400	
11600		MX=M
11700		M=1
11800	7	CALL OFILE(21,NM)
11900		IF(N2.EQ.'CONVT')GO TO 3
12000		J=JW(M+1)-JW(M)
12100		I=JR(M+1)-JR(M)+1
12200		P1=PWDS(JX+J)
12300		RX=NX-1
12350		IF(RX.EQ.0)GO TO 3
12400		DO 61 K=JX,JX+J-1
12500		KX=PWDS(K)
12600		PWDS(K)=KX-L
12700		KX=KX+2
12800	61	RN(KX)=RN(KX)-RX
12850		PWDS(JX+J)=PWDS(JX+J)-L
12900	3	L=I+IX-2
13000		WRITE(21)J,I,
13100		1 (PWDS(K),K=JX,JX+J),(RN(K),K=IX,L),ISCR,(V(K),K=1,ISCR),
13200		1 ISCR,(V(K),K=1,ISCR),(RSTFAC(K),K=NX,NX+7),(STFF(K),K=
13300		1 NX,NX+7),JR
13400		PWDS(JX+J)=P1
13500		TYPE 60,NM
13600	
13700		IF(M.EQ.MX)CALL EXIT
13800		M=M+1
13900		JX=JW(M)
14000		IX=JR(M)
14100	
14200		NX=NX+8
14300		END FILE 21
14400		NM=NM+2
14500		GO TO 7
14600	60	FORMAT(1XA5)
14700		END
14800	
14900		SUBROUTINE JJUST
15000		DATA RSP/.5/,RI/4.5/,RPX/.2/
15100		COMMON JY,L,R8,R9,RDIS /NNP/NP(2000)
15125		1 /MMV/MV(3000) /KJY/KY,LY
15150	C  INCREASE NP AND MV IF NEEDED
15200		COMMON/XRN/ RN(20000)/PTR/PWDS(2500) 
15300		1,RSTFAC(120),STFF(120),R(2,100),JR(120)/RR4/R4,R5,P1,P2,I,M
15400	
15500		DIMENSION IR(2,100)
15600		EQUIVALENCE (R,IR)
15800		IX=PWDS(I+1)-1
15900		PRCNT=1.
16100		RRT=P2
16150		R5=P2
16200		RZRO=P1
16300		R4=P1
16400		IF(RRT.EQ.0)RRT=200
16500		IF(RZRO.EQ.0)RZRO=.001
16600		JCNT=0
16700		RJSZ=RI
16800		CALL BIGGET
16850	C  BIG GETPTS FAIL ROUTINE
16900		ML=1
17000		ROV=RRT
17100	19	IF(JCNT.GT.9)GO TO 101
17110		RP=PRCNT
17200		RJSZ=RJSZ-RPX	
17300		JCNT=JCNT+1
17400	C  TEMPORARY COUNTER
17500		TYPE 111,JCNT
17600	111	FORMAT(I4)
17700	
17800		DO 11 KN=-3,M*8-4
17900		RSPC=0
18400		R8=KN
18500		N=0
18600	
18700		DO 2 K=1,KY
18800		L=NP(K)
18900		RA=RN(L+1)
19000		RB=RN(L+3)
19210		IF(RN(L+2).EQ.R8)GO TO 77
19220		IF(RA.NE.4)GO TO 2
19230	C  SKIPS HOMED NOTES (IN CHORDS)
19240	77	IF(RA.EQ.1)GO TO 10
19250	27	IF(RA.LE.4)GO TO 177
19260		IF(RA.LT.17)GO TO 2
19270	C  LOOKS AT NOTES,RESTS,CLEFS,BAR LINES,KSIGS,METERS.
19280	177	IF(RA.NE.4)GO TO 10
19290		IF(RN(L).GT.2)GO TO 2
19600	C  SHOULD CHECK ON BAR LINES NO MATTER WHICH STAFF
19700	10	N=N+1
19800		R(1,N)=RB
19900		IR(2,N)=L
20000		IF(N.EQ.100)GO TO 28
20100	C  ONLY TREATS 100 ITEMS AT A TIME.
20200	
20300	
20400	2	CONTINUE
20500	
20600		IF(N.EQ.0)GO TO 11
20700	CC28	KM=JFAC(L)
20800	C  SEE FUNCTION JFAC.  RSTFAC PNTR.
20900	28	DO 23 K=1,N
21000	23	IF(RN(IR(2,K)+1).NE.4)GO TO 24
21100	C  SKIPS IF ONLY BAR LINES ON THIS STAFF
21200		GO TO 11
21300	24	RSTJC=RSTFAC(KN+4)*PRCNT
21400		CALL SORT2(R,N)
21500	
21600	C  JUMP IF LAST IS A BAR LINE.
21700		K=0
21800		JLDGR=0
21900	     	JX=0
22000	22	K=K+1
22100	122	L=IR(2,K)
22200		RA=RN(L+1)
22300		RB=0
22400		RX=RN(L+5)
22410	C  RX=PARAM 5
22455		RX6=RN(L+6)
22500		RY=1
22600		RW=AMOD(RN(L+4),100.)
22700		IF(RA.GT.1)GO TO 4
22800		RZ=RN(L+7)
22900		IF(LDGR.NE.JLDGR)JLDGR=0
23000		LDGR=0
23100		JY=K
23200		DO 32 JJ=JY+1,N+1
23300		K=JJ
23400	32	IF(R(1,JJ)-R(1,JJ-1).GT.RSP)GO TO 35
23500	C  FOUND HOW MANY MEMBERS TO CHORD.
23600	35	RB=0
23700		K=K-1
23800		RQ=0
23900		RD=0
24000	125	IF(AMOD(RN(L+4),200.).GT.60.)RY=.6
24100		DO 37 JJ=JY,K-1
24200		IF(RD.NE.0)GO TO 38
24300	C FINDS ONLY HIGH OR! LOW LED. LINE.
24400		JIR=IR(2,JJ)
24500		RW=AMOD(RN(JIR+4),100.)
24600		IF(RW.GT.12)GO TO 277
24610		IF(RW.GE.2)GO TO 38
24620	277	LDGR=-1
24800		IF(RW.GT.12)LDGR=1
24900		IF(JLDGR.EQ.LDGR)GO TO 36
25000		JLDGR=LDGR
25100	C LDGR IS FOR LEDGER LINES.
25200		GO TO 38
25300	36	RD=1.5
25400		RQ=RD
25500	38	IF(RB.GT.2)GO TO 222
25600	C  JUMP IF LARGE SPACE AFTER NOTE IS ALREADY SET UP.
25700		RZZ=RN(JIR+7)
25800		RE=RN(JIR+5)
26210		IF(RB.GE.2)GO TO 477
26220		IF(RZZ.GE.10)GO TO 377
26230		IF(RE.GE.20)GO TO 477
26240		IF(AMOD(RZZ,10.).EQ.0)GO TO 477
26250	377	RB=1.5+EXTEN(RZZ)
26260	C  SPACE FOR DOT OR TAIL(IF STEM UP)
26270	477	IF(ABS(RN(JIR+6)).EQ.10)RB=RB+2
26300	C  FOR CHORD TONES ON RIGHT OF STEM UP.
26400	C  LOOKS THROUGH ALL NOTES OF A CHORD.
26500	222	IF(AMOD(RE,10.).EQ.0)GO TO 37 
26600	C  JUMP IF NO ACCIS.
26700	425	RD=2*RY+EXTEN(RE)
26800		IF(RQ.GT.RD)RD=RQ
26900		RQ=RD
27000	C  FUNCT. EXTEN=AMOD(X,1.)*10.
27100	37 	CONTINUE
27200		IF(RY.NE.1)RB=RB-.5*RJSZ
27300	C  MINI NOTES NEED LESS SPACE
27400	25	IF(JX.GT.0)R(2,JX)=R(2,JX)+RD*RSTJC
27500		GO TO 17
27600	4	IF(RA.NE.3)GO TO 29
27700		RB=3
27800		IF(RX.GT.100)RB=1.5
27900	C  CHECK ON SIZE NEEDED FOR CLEFS
28000	29	IF(RA.NE.4)GO TO 26
28100		RB=-RJSZ/2
28200		RD=.9
28300		GO TO 25
28400	26	IF(RA.NE.18)GO TO 30
28500		IF(RX6.GT.9)GO TO 31
28510		IF(RX.GT.9)GO TO 31
28600	C  CHECKS FOR 2-DIGIT METERS
28700		RB=-1
28800		RD=1
28900		GO TO 25
29000	31	RB=2
29100		RD=3
29200		GO TO 25
29300	30	IF(RA.NE.17)GO TO 17
29500		RB=2*(ABS(RX)-1)-2
29600		RD=2
29700		GO TO 25
29800	C  SPACES FOR CORRECT NUM OF ACCIS.
29900	17	RC=(RB+RJSZ)*RSTJC
30000	C  RJSZ=DEFAULT SIZE
30100		JX=JX+1
30200		R(2,JX)=RC
30300		R(1,JX)=R(1,K)
30400	3	IF(K.LT.N)GO TO 22
30500		RA=R(1,1)
30600		RB=R(2,1)
30700	
30800		DO 13 KX=2,JX
30900		RE=R(1,KX)
31000	C  POS. BEFORE SHIFTING
31100		IF(ABS(RE-RA).GT..5)GO TO 14
31200		IF(R(2,KX).GT.RB)GO TO 16
31300	C  SKIPS DOUBLE STOPS AND VERY CLOSE ITEMS
31400		GO TO 13
31500	CC	IF(RZZ.LE.RB)GO TO 13
31600	C  JUMP WHEN SPACE TO ADD IS SMALLER THAN WHAT'S ALREADY THERE
31700	CC	RB=RZZ-RB
31800	14	RD=RA+RB-RE
31900		IF(RD.LE.0)GO TO 16
32000	C  THERE'S ENOUGH ROOM
32100	CC	RD=RA+RB-RE+RD
32150		ROV=ROV+RD
32175	
32200	140	R4=RE+RSPC-.001
32300		R5=1000
32400	C  MAYBE MORE? ↑↑↑↑↑
32500		R8=RD
32600		R9=0
32900	C  GO EXPAND IT
33000		IF(R(2,KX).EQ.0)GO TO 15
33010		CALL MOVIT
33020		R5=R4
33030		R4=RA+.001+RSPC
33040		R8=R4
33050		R9=R5+RD-.001
33060	C  FOR ITEMS ON OTHER LINES.
33070		CALL MOVIT
33080	15	RSPC=RSPC+RD
33090	C  RSPC SAVES TOTAL SPACE ADDED
33100	16	RB=R(2,KX)
33200	13	RA=RE
33300	11	CONTINUE
33400	110	IF(ROV.LE.RRT+.01)RETURN  
33500		IF(RJSZ.GT.4)RJSZ=4
33600		PRCNT=(ROV-RZRO)/(RRT-RZRO)
34000		IF(PRCNT.NE.RP)GO TO 19
34100	101	R4=RZRO
34200		R5=ROV
34300		R8=RZRO
34400		R9=RRT-.001
34500	C  JUSTIFYING SPACE DIMINISHES EACH TIME AROUND.
34600		CALL MOVIT
34610		END
41900		
42000	C  THESE MOVE ENDS OF PARTIAL INNER BEAMS.
42100		SUBROUTINE MVBEAM(I)
42200	C  L AND JY ARE FOR MOVES TO DIFF. STAFF.
42310		COMMON JY,L,R8,R9,RDIS /XRN/RN(20000)
42400		Y=RN(JY+I)
42500		Z=ABS(Y)
42600		IF(Z.LT.100.)GO TO 1
42700	C  NEXT FOR MINIS, DIAMONDS, 'X' NOTES. (LIMIT OF +-99 ON ALTITUDE.)
42800		Y=AMOD(Y,100.)
42900		X=Y+R8
43000		Z=Z-ABS(Y)+ABS(X)
43100	C  PUTS ALL INTO POSITIVE
43200		IF(X)Z=-Z
43300		GO TO 2
43400	1	Z=Y+R8
43500	2	RN(L+I)=Z
43600		END